; ORIGINAL: 3dt2.1/examples/schemers/rbprocs.scm
; ---------------------------------------------------------------------
;;   File: RBPROCS.SCM
;;  Notes: A collection of programs that fulfill the goals of
;          the RUBBER BANDING project in Chapter 4 of the
;          "Getting Started" book.
;
;   Dated: 02 Feb 94  Edward C. Martin, Schemers Inc.
;
; Updated: 11 Nov 94  rcg  STI
; ---------------------------------------------------------------------

; Waits for a mouse button event and returns a position if
; the left button is pressed.  Otherwise, returns FALSE.
;
(define position:select (lambda args
    (let (
        (evt (read-ray)))
        (if (= (event:button evt) 1)
            (apply pick:position (cons evt args))
        ;; else
            #f)
        )
    ))

; Creates and returns a line rubber band driver.  It takes a
; vector argument whose only element is a position.  This is
; the start position of the line rubber band driver.
;
(define rb:create-line (lambda (rb_locals)
    (let* (
        ;; rubber band line
        (start_pos #f)
        (stop_pos  #f)

        ;; procedure to draw/undraw the rubber band polygon
        (draw (lambda ()
            (view:set-rb-mode #t)
            (view:draw-polyline (list start_pos stop_pos))
            (view:set-rb-mode #f)
            ))

        ;; rubber band hooks
        (rb_hooks (make-vector 7))
        )
        (vector-set! rb_hooks 0 (lambda (self)      ;; INIT
            (set! start_pos (rbd:scheme-get-local self 0))
            ))

        (vector-set! rb_hooks 1 (lambda (self pe)   ;; START
            (set! stop_pos (pick:position pe))
            (draw)
            ))

        (vector-set! rb_hooks 2 (lambda (self pe)   ;; UPDATE
            (draw)    ;; erase line
            (set! stop_pos (pick:position pe))
            (draw)    ;; draw line
            ))

        (vector-set! rb_hooks 3 (lambda (self)      ;; STOP
            (draw)    ;; erase line
            ))

        ;; return a new rubber band driver
        (rbd:scheme #f rb_hooks rb_locals)
        )
    ))


(define spline (lambda ()
    (let (
        (locals (make-vector 1))        ;; rb line start/end position
        (driver #f)                     ;; rb line driver
        (start_pos (position:select))
        )

        (if (not start_pos)
            'stop
        ;; else
            (letrec (
                ;; recursive procedure for drawing spline outline
                (build (lambda (pos_list)
                    (let (
                        (next_pos (position:select))
                        )
                        (if (not next_pos)
                            (begin
                            ;; stop rubberbanding
                            (rbd:clear)
                            (if (= (length pos_list) 1)
                                'quit
                            ;; else
                                ;; go into the spline edit mode
                                (spline-edit pos_list)
                                )
                            )

                        ;; else

                            (begin
                            ;; pop rb driver
                            (rbd:pop)

                            ;; store mouse position and draw temporary lines
                            (set! pos_list (append pos_list (list next_pos)))
                            (view:draw-polyline pos_list)
                            (view:draw-point next_pos)

                            ;; push rb driver
                            (vector-set! locals 0 next_pos)
                            (rbd:push driver)

                            ;; recursive call
                            (build pos_list)
                            ))
                        )
                    ))
                )

                ;; start the process

                (view:draw-point start_pos)

                (vector-set! locals 0 start_pos)
                (set! driver (rb:create-line locals))
                (rbd:push driver)

                (build (list start_pos))
                )
            )
        )
    ))


; Allows the user to adjust the individual positions within a list of
; positions, and returns the edge:spline they determine once the adjustment
; has been completed.
;
(define spline-edit (lambda (pos_list)
    (let (
        (pos_vec (list->vector pos_list))
        (len_vec (- (length pos_list) 1))  ;; zero based

        ;; the spline edit rubberbanding is performed with two
        ;; active rubber band drivers
        (locals1 (make-vector 1))  (locals2 (make-vector 1))
        (driver1 #f)               (driver2 #f)
        )
        (letrec (

            ;; Purpose: draws the spline and its vertices
            ;;
            (draw-spline (lambda (vec)
                (view:refresh)            ;; clear temporary geometry
                (view:draw-points vec)    ;; draw vertices
                (edge:spline (vector->list vec))
                ))

            ;;  Purpose: Set rubber band drivers.
            ;;
            (rb-vertex (lambda (vec index)
                (cond
                    ;; start vertex
                    ((= index 0)
                        (begin
                        (vector-set! locals1 0 (vector-ref vec (+ index 1)))
                        (rbd:push driver1)
                        ))

                    ;; end vertex
                    ((= index len_vec)
                        (begin
                        (vector-set! locals1 0 (vector-ref vec (- index 1)))
                        (rbd:push driver1)
                        ))

                    (else
                        (vector-set! locals1 0 (vector-ref vec (- index 1)))
                        (vector-set! locals2 0 (vector-ref vec (+ index 1)))
                        (rbd:push driver1)
                        (rbd:add  driver2)
                        )
                    )
                ))

            ;; Purpose: Edit the spline shape by allowing the
            ;;          user to adjust the vertices.
            ;;
            (edit (lambda (vec idx)
                (if (not idx)
                    (begin
                    (rbd:clear)
                    (draw-spline vec))

                ;; else

                    (let (
                        (new_pos (position:select))
                        )

                        (if (not new_pos)
                            (begin
                            (rbd:clear)
                            (draw-spline vec))

                        ;; else

                            (begin
                            (vector-set! vec idx new_pos)
                            (rbd:pop)
                            (view:refresh)
                            (view:draw-polyline vec)
                            (view:draw-points vec)

                            (let (
                                (new_idx (find-idx (position:select) vec))
                                )
                                (if (not new_idx)
                                    (draw-spline vec)
                                ;; else
                                    (begin
                                    (rb-vertex vec new_idx)
                                    (edit vec new_idx)
                                    ))
                                ))
                            )
                        )
                    )
                ))
            )

            ;; start the process

            (let (
                ;; pick a vertice
                (idx (find-idx (position:select) pos_vec))
                )
                (if (not idx)
                    (draw-spline pos_vec)
                ;; else
                    (begin

                    ;; create rubber band drivers
                    (set! driver1 (rb:create-line locals1))
                    (set! driver2 (rb:create-line locals2))

                    (rb-vertex pos_vec idx)

                    (edit pos_vec idx)
                    ))
                )
            )
        )
    ))

; Finds the index of a position from a vector of positions that is within
; the aperture of a mouse pick.  If no position is with tolerance, this
; procedure returns FALSE.  The position is generated from a call to
; position:select so the input may be FALSE.
;
(define find-idx (lambda (pos pvec)
    (let (
        ;; The mouse has a square aperture with a size in pixels, not
        ;; distance.  We select the aperture width and convert it into
        ;; a length (distance) tolerance for the view.
        ;;
        ;; aperture_width * window_width / viewport_width
        ;;
        (tol (/ (* (car (pick:aperture)) (view:width))
                (caddr (view:viewport))))

        (n (vector-length pvec))
        )

        (letrec (

            (search (lambda (k)
                (cond
                    ((= k n)
                        #f)
                    ((<= (position:distance pos (vector-ref pvec k)) tol)
                        k)
                    (else
                        (search (+ k 1)))
                    )
                ))
            )

            ;; start process

            (if (not pos)
                #f
            ;; else
                (search 0)
                )
            )
        )
    ))


; Temporarily draws all vertices from the input vector of positions.
;
(define view:draw-points (lambda (pvec)
    (for-each view:draw-point (vector->list pvec))
    ))


;; ---------------------------------
;;  End of RBPROCS.SCM
;; ---------------------------------


